home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / comps / gadgets / delphi10 / ulbitmap / ulbitmap.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-16  |  7.4 KB  |  247 lines
  1. unit Ulbitmap;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs;
  8.  
  9. type
  10.   TUnlimitedBitmap = class(TComponent)
  11.   private
  12.     { Private declarations }
  13.     FOnLoadBMP : TNotifyEvent;
  14.     FOnCreate  : TNotifyEvent;
  15.     FOnDestroy : TNotifyEvent;
  16.   protected
  17.     { Protected declarations }
  18.   public
  19.     { Public declarations }
  20.     Bitmap_Handle    : HBitmap;   { Holds the DIB when done               }
  21.     Width            : Longint;   { Holds the pixel width when done       }
  22.     Height           : Longint;   { Holds the pixel height when done      }
  23.     The_File         : File;      { File variable for internal use        }
  24.     The_Name         : String;    { Holds the file name                   }
  25.     Bits_Handle      : THandle;   { temporary holder for the DIB          }
  26.     Bits_Byte_Size   : Longint;   { temporary holder for the              }
  27.                                   { byte length of the DIB                }
  28.     Error_Status     : Integer;   { code for error condition on the DIB   }
  29.     TheBMP     : TBitmap;
  30.     constructor Create( AOwner : TComponent ); override;
  31.     procedure Initialize( The_DIB_Name : String );
  32.     destructor Destroy; override;
  33.     procedure Get_Bitmap_Data;
  34.     function Get_Bitmap : HBitmap;
  35.     function Load_Bitmap_File : Boolean;
  36.     function Open_DIB : Boolean;
  37.     function Get_Error_Status : Integer;
  38.     procedure Get_DIB_Dimensions( var The_Width  ,
  39.                                       The_Height   : Longint );
  40.   published
  41.     { Published declarations }
  42.     property FileName : String read The_Name write The_Name;
  43.     property OnCreate : TNotifyEvent read FOnCreate write FOnCreate;
  44.     property OnDestroy : TNotifyEvent read FOnDestroy write FOnDestroy;
  45.     property OnLoadBitmapFile : TNotifyEvent read FOnLoadBMP write FOnLoadBMP;
  46.   end;
  47.  
  48. procedure Register;
  49.  
  50. implementation
  51.  
  52. procedure AHIncr; FAR; EXTERNAL 'KERNEL' INDEX 114;
  53.  
  54. { This creates a file bitmap object }
  55. constructor TUnlimitedBitmap.Create( AOwner : TComponent );
  56. begin
  57.   { call inherited FIRST! }
  58.   inherited Create( AOwner );
  59.   { Zero out the data elements }
  60.   Bitmap_Handle := 0;
  61.   The_Name := '';
  62.   TheBMP := TBitmap.Create;
  63.   if Assigned(FOnCreate) then OnCreate( Self );
  64. end;
  65.  
  66. { This procedure sets up the bitmap filename to load }
  67. procedure TUnlimitedBitmap.Initialize( The_DIB_Name : String );
  68. begin
  69.   The_Name := The_DIB_Name;
  70. end;
  71.  
  72. { This is the destructor procedure }
  73. destructor TUnlimitedBitmap.Destroy;
  74. begin
  75.   if Assigned(FOnDestroy) then OnDestroy(Self);
  76.   TheBMP.Free;
  77.   { Assume bitmap handle given to TBitmap and cleared there }
  78.   { call inherited last }
  79.   inherited destroy;
  80. end;
  81.  
  82. { This method copies the bitmap bits data from the file into memory. Since }
  83. { copying cannot cross a segment (64K) boundary, segment arithmetic must   }
  84. { be done on the fly.  A LongType type was created to simplify this process}
  85. procedure TUnlimitedBitmap.Get_Bitmap_Data;
  86.  
  87. type
  88.   LongType = record
  89.   case Word of
  90.     0: ( Ptr  : Pointer );
  91.     1: ( Long : Longint );
  92.     2: ( Lo   : Word;
  93.          Hi   : Word    );
  94.   end;
  95. var
  96.   Count   : Longint;
  97.   Start,
  98.   ToAddr,
  99.   Bits    : LongType;
  100. begin
  101.   Start.Long := 0;
  102.   Bits.Ptr := GlobalLock( Bits_Handle );
  103.   Count := Bits_Byte_Size - Start.Long;
  104.   while Count > 0 do
  105.   begin
  106.     ToAddr.Hi := Bits.Hi + ( Start.Hi * OFS( AHIncr ));
  107.     ToAddr.Lo := Start.Lo;
  108.     if Count > $4000 then Count := $4000;
  109.     BlockRead( The_File , ToAddr.Ptr^ , Count );
  110.     Start.Long := Start.Long + Count;
  111.     Count := Bits_Byte_Size - Start.Long;
  112.   end;
  113.   GlobalUnlock( Bits_Handle );
  114. end;
  115.  
  116. { This returns the handle to the stored bitmap }
  117. function TUnlimitedBitmap.Get_Bitmap : HBitmap;
  118. begin
  119.   Get_Bitmap := Bitmap_Handle;
  120. end;
  121.  
  122. { This is the function to call to load a bitmap file of any size }
  123. { If no errors occur it returns true, otherwise false; use GEC   }
  124. { (Some portions of this code are copyright Borland Intl, 1990.) }
  125. function TUnlimitedBitmap.Load_Bitmap_File : Boolean;
  126. var
  127.   Test_Win30_Bitmap : Longint;
  128.   Memory_DC         : HDC;
  129.   The_IO_Result     : Word;
  130. begin
  131.   if Assigned(FOnLoadBMP) then OnLoadBitmapFile( Self );
  132.   if The_Name = '' then exit;
  133.   Error_Status := 0;
  134.   Load_Bitmap_File := false;
  135.   AssignFile( The_File , The_Name );
  136.   {$I-}
  137.   Reset( The_File , 1 );
  138.   Seek( The_File , 14 );
  139.   BlockRead( The_File , Test_Win30_Bitmap , SizeOf( Test_Win30_Bitmap ));
  140.   {$I+}
  141.   The_IO_Result := IOResult;
  142.   If The_IO_Result <> 0 then
  143.   begin
  144.     Error_Status := -1;
  145.   end
  146.   else
  147.   begin
  148.     if Test_Win30_Bitmap = 40 then
  149.     begin
  150.       if Open_DIB then
  151.       begin
  152.         Load_Bitmap_File := true;
  153.       end;
  154.     end
  155.     else
  156.     begin
  157.       Error_Status := -2;
  158.     end;
  159.     CloseFile( The_File );
  160.   end;
  161.   TheBMP.Handle := Bitmap_Handle;
  162.   TheBMP.Height := Height;
  163.   TheBMP.Width := Width;
  164. end;
  165.  
  166. { This does the actual loading of the bitmap's info }
  167. function TUnlimitedBitmap.Open_DIB : Boolean;
  168. var
  169.   Bit_Count         : Word;
  170.   Size              : Word;
  171.   Long_Width        : Longint;
  172.   DC_Handle         : HDC;
  173.   Bits_Ptr          : Pointer;
  174.   Bitmap_Info       : PBitmapInfo;
  175.   New_Bitmap_Handle : THandle;
  176.   New_Pixel_Width,
  177.   New_Pixel_Height  : Word;
  178. begin
  179.   Open_DIB := true;
  180.   Seek( The_File , 28 );
  181.   BlockRead( The_File , Bit_Count , SizeOf( Bit_Count ));
  182.   if Bit_Count <= 8 then
  183.   begin
  184.     Size := SizeOf( TBitmapInfoHeader ) + (( 1 SHL Bit_Count )
  185.      * SizeOf( TRGBQuad ));
  186.     Bitmap_Info := MemAlloc( Size );
  187.     Seek( The_File , SizeOf( TBitmapFileHeader ));
  188.     BlockRead( The_File , Bitmap_Info^ , Size );
  189.     New_Pixel_Width := Bitmap_Info^.bmiHeader.biWidth;
  190.     New_Pixel_Height := Bitmap_Info^.bmiHeader.biHeight;
  191.     Long_Width := ((( New_Pixel_Width * Bit_Count ) + 31 ) div 32 ) * 4;
  192.     Bitmap_Info^.bmiHeader.biSizeImage := Long_Width * New_Pixel_Height;
  193.     {GlobalCompact( -1 );}
  194.     Bits_Handle := GlobalAlloc( gmem_Moveable or gmem_Zeroinit ,
  195.                                 Bitmap_Info^.bmiHeader.biSizeImage );
  196.     Bits_Byte_Size := Bitmap_Info^.bmiHeader.biSizeImage;
  197.     Get_Bitmap_Data;
  198.     DC_Handle := CreateDC( 'Display' , nil , nil , nil );
  199.     Bits_Ptr := GlobalLock( Bits_Handle );
  200.     New_Bitmap_Handle :=
  201.     CreateDIBitmap( DC_Handle , Bitmap_Info^.bmiHeader ,
  202.                     cbm_Init , Bits_Ptr , Bitmap_Info^ , 0 );
  203.     DeleteDC( DC_Handle );
  204.     GlobalUnlock( Bits_Handle );
  205.     GlobalFree( Bits_Handle );
  206.     FreeMem( Bitmap_Info , Size );
  207.     if New_Bitmap_Handle <> 0 then
  208.     begin
  209.       if Bitmap_Handle <> 0 then DeleteObject( Bitmap_Handle );
  210.       Bitmap_Handle := New_Bitmap_Handle;
  211.       Width := New_Pixel_Width;
  212.       Height := New_Pixel_Height;
  213.     end
  214.     else
  215.     begin
  216.       Open_DIB := false;
  217.       Error_Status := -4;
  218.     end;
  219.   end
  220.   else
  221.   begin
  222.     Open_DIB := false;
  223.     Error_Status := -3;
  224.   end;
  225. end;
  226.  
  227. { This is an OOP return of the error variable }
  228. function TUnlimitedBitmap.Get_Error_Status : Integer;
  229. begin
  230.   Get_Error_Status := Error_Status;
  231. end;
  232.  
  233. { This is an OOP return of the dimensions of the DIB }
  234. procedure TUnlimitedBitmap.Get_DIB_Dimensions( var The_Width  ,
  235.                                               The_Height   : Longint );
  236. begin
  237.   The_Width := Width;
  238.   The_Height := Height;
  239. end;
  240.  
  241. procedure Register;
  242. begin
  243.   RegisterComponents('Gadgets', [TUnlimitedBitmap]);
  244. end;
  245.  
  246. end.
  247.